Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue26/survive/MYDS.PAS

Pascal/Delphi Source File | 1997-08-21 | 18.1 KB | 590 lines

unit MyDS;

interface

uses
  Classes, DB, DBConsts, SysUtils;

type
  PExtraRecInfo = ^TExtraRecInfo;
  TExtraRecInfo = record
      RecordNumber: LongInt;
      BookmarkFlag: TBookmarkFlag;
    end;

  TBookmarkInfo = LongInt;

  TMyDataSet = class(TDataSet)
    private
      FBookmarkOffset: LongInt;  { Offset to bookmark data in recbuf }
      FCalcFieldsOffset: Word;   { Offset to calculated fields data }
      FCursorOpen: Boolean;      { True if cursor is open }
      FInternalFile: file;       { File variable }
      FRecSize: Word;            { Physical size of record }
      FRecBufSize: Word;         { Total size of recbuf }
      FExtraRecInfoOffset: Word; { Offset to extra rec info in recbuf }
      FTableName: TFileName;     { External filename to open }
      FNullFlagsOffset: Word;    { Offset to null flags in recbuf }
    protected

      { basic file reading and navigation }
      function AllocRecordBuffer: PChar; override;
      procedure FreeRecordBuffer(var Buffer: PChar); override;
      function GetCurrentRecord(Buffer: PChar): Boolean; override;
      function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
      function GetRecordCount: Integer; override;
      function GetRecordSize: Word; override;
      function GetRecNo: Integer; override;
      procedure InternalClose; override;
      procedure InternalFirst; override;
      procedure InternalLast; override;
      procedure InternalOpen; override;
      procedure InternalRefresh; override;
      function IsCursorOpen: Boolean; override;

      { bookmarks }
      function BookmarkValid(Bookmark: TBookmark): Boolean; override;
      function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
      procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
      function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
      procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
      procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
      procedure InternalGotoBookmark(Bookmark: Pointer); override;
      procedure InternalSetToRecord(Buffer: PChar); override;

      { basic file modification }
      procedure InternalInitRecord(Buffer: PChar); override;
      procedure InternalEdit; override;
      procedure InternalDelete; override;
      procedure InternalPost; override;

      { field component stuff }
      procedure InternalInitFieldDefs; override;
      function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
      procedure SetFieldData(Field: TField; Buffer: Pointer); override;
      procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;

      { calculated fields }
      procedure ClearCalcFields(Buffer: PChar); override;
    protected
      { our own custom stuff }
      FieldOffsets: TList;
    public
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
      property RecordSize: Word read GetRecordSize;  { from TDataSet }
      property TableName: TFileName read FTableName write FTableName;
    end;

implementation

constructor TMyDataSet.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FieldOffsets := TList.Create;
end;

destructor TMyDataSet.Destroy;
begin
  FieldOffsets.Free;
  inherited Destroy;
end;

function TMyDataSet.AllocRecordBuffer: PChar;
begin
  Result := StrAlloc(FRecBufSize);
  FillChar(Result^, FRecBufSize, #0);
end;

function TMyDataSet.BookmarkValid(Bookmark: TBookmark): Boolean;
var
  DelFlag: Byte;
begin
  Result := Assigned(Bookmark) and
            (TBookmarkInfo(Bookmark^) > 0) and
            (TBookmarkInfo(Bookmark^) <= RecordCount);
  if Result then begin
    CursorPosChanged;  { physical position no longer matches logical position }
    try
      Seek(FInternalFile, TBookmarkInfo(Bookmark^) * FRecSize);
      BlockRead(FInternalFile, DelFlag, 1);
      Result := DelFlag = 0;  { check for a deleted record }
    except
      Result := False;
    end;
  end;
end;

procedure TMyDataSet.ClearCalcFields(Buffer: PChar);
begin
  FillChar(Buffer[FCalcFieldsOffset], CalcFieldsSize, 0);
end;

function TMyDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer;
begin
  { bookmarks are equal if they are both nil or they both have the same value }
  if Bookmark1 = Bookmark2 then
    Result := 0
  else begin
    Result := 1;
    if Assigned(Bookmark1) and Assigned(Bookmark2) then
      if TBookmarkInfo(Bookmark1^) = TBookmarkInfo(Bookmark2^) then
        Result := 0;
  end;
end;

procedure TMyDataSet.FreeRecordBuffer(var Buffer: PChar);
begin
  StrDispose(Buffer);
end;

procedure TMyDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
begin
  Move(Buffer[FBookmarkOffset], Data^, BookmarkSize);
end;

function TMyDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
begin
  Result := PExtraRecInfo(Buffer + FExtraRecInfoOffset).BookmarkFlag;
end;

function TMyDataSet.GetCurrentRecord(Buffer: PChar): Boolean;
begin
  Result := False;
  if not IsEmpty then begin
    Result := True;
    Move(ActiveBuffer^, Buffer^, FRecSize);  {not sure here, buffer may contain internal data}
  end;
end;

function TMyDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
{ Get the data for the given field from the active buffer and stick it
  in the given buffer.  Return False if the field value is null; otherwise
  return True. Buffer may be nil if TDataSet is checking for null only. }
var
  Offset,
  DataSize: Integer;
  NullFlags: ^LongInt;
  TimeStamp: TTimeStamp;  { TTimeStamp declared in SysUtils }
  DateTime: TDateTime;
  RecBuf: PChar;
begin
  RecBuf := ActiveBuffer;
  if State = dsCalcFields then
    RecBuf := CalcBuffer;

  if Field.FieldNo <> -1 then begin   { a physical field }

    { Check for a null value }
    NullFlags := @RecBuf[FNullFlagsOffset];
    Result := ((NullFlags^ and (1 shl (Field.FieldNo - 1))) = 0);

    { If value is not null }
    if Result and Assigned(Buffer) then begin
      FillChar(Buffer^, Field.DataSize, 0);
      Offset := LongInt(FieldOffsets[Field.FieldNo - 1]);
      DataSize := Field.DataSize;

      { Special handing for date/time fields }
      if Field.DataType in [ftDateTime, ftDate, ftTime] then begin
        Move(RecBuf[Offset], DateTime, DataSize);
        TimeStamp := DateTimeToTimeStamp(DateTime);
        case Field.DataType of
          ftDate: TDateTimeRec(Buffer^).Date := TimeStamp.Date;
          ftTime: TDateTimeRec(Buffer^).Time := TimeStamp.Time;
          else
            TDateTimeRec(Buffer^).DateTime := TimeStampToMSecs(TimeStamp);
        end;
      end
      else begin
        if Field.DataType = ftString then begin
          DataSize := Byte(RecBuf[Offset]);
          Inc(Offset);
        end;
        Move(RecBuf[Offset], Buffer^, DataSize);
      end;
    end;
  end
  else begin   { a calculated field }
    Offset := FCalcFieldsOffset + Field.Offset;
    Result := not Boolean(RecBuf[Offset]);
    if Result and Assigned(Buffer) then begin
      Move(RecBuf[Offset + 1], Buffer^, Field.DataSize);
    end;
  end;
end;

function TMyDataSet.GetRecNo: Integer;
begin
  { Because of Delphi's internal record buffering, we must read the stored
    record number, not the current physical file position }
  Result := PExtraRecInfo(ActiveBuffer + FExtraRecInfoOffset)^.RecordNumber;
end;

function TMyDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult;
var
  FilePosition: LongInt;
begin
  Result := grOk;
  case GetMode of
    gmCurrent:
      begin
        Seek(FInternalFile, FilePos(FInternalFile) - FRecSize);
        BlockRead(FInternalFile, Buffer^, FRecSize);
        if Byte(Buffer^) <> 0 then  { deleted rec? }
          Result := grError;
      end;
    gmNext:
      { read next record, skipping deleted records }
      repeat
        if System.Eof(FInternalFile) then
          Result := grEOF
        else
          BlockRead(FInternalFile, Buffer^, FRecSize);
      until (Result <> grOk) or (Byte(Buffer^) = 0);
    gmPrior:
      repeat
        FilePosition := FilePos(FInternalFile);
        if FilePosition < (2 * FRecSize) then
          Result := grBOF
        else begin
          if Eof then
            Seek(FInternalFile, FileSize(FInternalFile) - FRecSize)
          else
            Seek(FInternalFile, FilePosition - (2 * FRecSize));
          BlockRead(FInternalFile, Buffer^, FRecSize);
        end;
      until (Result <> grOk) or (Byte(Buffer^) = 0);
    else
      Result := grError;
  end;

  if Result = grOk then begin
    GetCalcFields(Buffer);
    with PExtraRecInfo(Buffer + FExtraRecInfoOffset)^ do begin
      RecordNumber := (FilePos(FInternalFile) div FRecSize) - 1;
      BookmarkFlag := bfCurrent;
      SetBookmarkData(Buffer, @RecordNumber);
    end;
  end;
end;

function TMyDataSet.GetRecordCount: Integer;
begin
  { Note this returns the total number of records, including
    deleted records.  Ideally we would store the number of "active"
    records in a file header record. }
  Result := FileSize(FInternalFile) div FRecSize;
end;

function TMyDataSet.GetRecordSize: Word;
begin
  Result := FRecSize;
end;

procedure TMyDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
begin
  { In our case, is doesn't matter if the record is being appended,
    inserts and appends both get written to the end of the file. }
  Byte(Buffer^) := 0;  { reset deleted flag as a precaution }
  Seek(FInternalFile, FileSize(FInternalFile));
  BlockWrite(FInternalFile, Buffer^, FRecSize);
end;

procedure TMyDataSet.InternalClose;
begin

  { Destroy the TField components if no persistent fields }
  if DefaultFields then DestroyFields;

  { InternalClose is called by the Fields Editor in design mode, so
    the actual table may not be open. }
  if FCursorOpen then
    CloseFile(FInternalFile);
  FCursorOpen := False;
end;

procedure TMyDataSet.InternalDelete;
var
  DelFlag: Byte;
  FilePosition: LongInt;
begin
  FilePosition := FilePos(FInternalFile) - FRecSize;
  Seek(FInternalFile, FilePosition);
  DelFlag := 255;
  BlockWrite(FInternalFile, DelFlag, 1);
  Seek(FInternalFile, FilePosition + FRecSize);
end;

procedure TMyDataSet.InternalEdit;
begin
  { Refresh the current record }
  Seek(FInternalFile, FilePos(FInternalFile) - FRecSize);
  BlockRead(FInternalFile, ActiveBuffer^, FRecSize);
end;

procedure TMyDataSet.InternalFirst;
begin
  Seek(FInternalFile, 0);
end;

procedure TMyDataSet.InternalInitFieldDefs;
var
  DictFile: TextFile;
  DictRec: ShortString;
  FieldNo: Integer;
  FieldName: ShortString;
  Required: Boolean;
  DataType: TFieldType;
  Size: Word;
  ActualSize: Word;

  procedure GetNextAttribute(Rec: ShortString; var Attribute, OutRec: ShortString);
  var
    I: Integer;
  begin
    I := 1;
    Attribute := '';
    OutRec := '';
    if Rec = '' then Exit;
    while (I <= Length(Rec)) and (Rec[I] <> ',') do begin
      if not (Rec[I] in [' ', #9]) then
        Attribute := Attribute + Rec[I];
      Inc(I);
    end;
    if I < Length(Rec) then
      OutRec := Copy(Rec, I + 1, Length(Rec));
  end;

  procedure ParseDictRec;
  var
    DataTypeStr: ShortString;
    TempSize: Integer;
    Attribute: ShortString;
  begin
    { Get field name }
    GetNextAttribute(DictRec, FieldName, DictRec);
    if FieldName = '' then Exit;
    { Get data type }
    GetNextAttribute(DictRec, DataTypeStr, DictRec);
    { Get size }
    GetNextAttribute(DictRec, Attribute, DictRec);
    TempSize := 0;
    if Attribute <> '' then TempSize := StrToInt(Attribute);
    { Get null/not null }
    GetNextAttribute(DictRec, Attribute, DictRec);
    Attribute := Uppercase(Attribute);
    Required := Attribute <> 'NULL';

    Size := 0;
    ActualSize := 0;
    DataTypeStr := Uppercase(DataTypeStr);
    if DataTypeStr = 'SMALLINT' then begin
      DataType := ftSmallInt;
      ActualSize := SizeOf(SmallInt);
    end
    else if DataTypeStr = 'INTEGER' then begin
      DataType := ftInteger;
      ActualSize := SizeOf(Integer);
    end
    else if DataTypeStr = 'WORD' then begin
      DataType := ftWord;
      ActualSize := SizeOf(Word);
    end
    else if DataTypeStr = 'SINGLE' then begin
      DataType := ftFloat;
      ActualSize := SizeOf(Single);
    end
    else if DataTypeStr = 'DOUBLE' then begin
      DataType := ftFloat;
      ActualSize := SizeOf(Double);
    end
    else if DataTypeStr = 'STRING' then begin
      DataType := ftString;
      ActualSize := TempSize + 1;
      Size := TempSize;
    end
    else if DataTypeStr = 'DATETIME' then begin
      DataType := ftDateTime;
      ActualSize := SizeOf(TDateTime);
    end
    else
      DataType := ftUnknown;
  end;
begin
  FieldDefs.Clear;
  AssignFile(DictFile, ChangeFileExt(FTableName, '.DIC'));
  Reset(DictFile);
  try
    FRecSize := 1;  {skip the delete flag field}
    FieldNo := 0;
    while not System.Eof(DictFile) do begin
      ReadLn(DictFile, DictRec);
      Inc(FieldNo);
      ParseDictRec;
      if FieldName <> '' then begin
        FieldOffsets.Add(Pointer(FRecSize));  { store field offset }
        Inc(FRecSize, ActualSize);            { compute our record size }
        TFieldDef.Create(FieldDefs, FieldName, DataType, Size, Required, FieldNo);
      end;
    end;
    FNullFlagsOffset := FRecSize;
    Inc(FRecSize, SizeOf(LongInt));  { Record size includes null flags space }
  finally
    CloseFile(DictFile);
  end;
end;

procedure TMyDataSet.InternalInitRecord(Buffer: PChar);
begin
  FillChar(Buffer^, FRecBufSize, #0);
end;

procedure TMyDataSet.InternalGotoBookmark(Bookmark: Pointer);
{ position physical file to bookmarked record }
begin
  { Position AFTER the record, as though we just read it }
  Seek(FInternalFile, (TBookmarkInfo(Bookmark^) + 1) * FRecSize);
end;

procedure TMyDataSet.InternalLast;
begin
  Seek(FInternalFile, FileSize(FInternalFile));  { force eof condition }
end;

procedure TMyDataSet.InternalOpen;
begin
  AssignFile(FInternalFile, FTableName);
  Reset(FInternalFile, 1);   { Open a file of bytes }
  FCursorOpen := True;

  InternalInitFieldDefs;              { Populate FieldDefs from external dict }
  if DefaultFields then CreateFields; { Populate Fields from FieldDefs }
  BindFields(True);

  BookmarkSize := SizeOf(TBookmarkInfo);

  { Compute offsets to various record buffer segments }
  FCalcFieldsOffset := FRecSize;
  FExtraRecInfoOffset := FCalcFieldsOffset + CalcFieldsSize;
  FBookmarkOffset := FExtraRecInfoOffset + SizeOf(TExtraRecInfo);
  FRecBufSize := FBookmarkOffset + BookmarkSize;
end;

procedure TMyDataSet.InternalPost;
begin
  case State of
    dsEdit:
      begin
        Seek(FInternalFile, FilePos(FInternalFile) - FRecSize);
        BlockWrite(FInternalFile, ActiveBuffer^, FRecSize);
      end;
    dsInsert:
      begin
        Byte(ActiveBuffer^) := 0;  { reset deleted flag }
        Seek(FInternalFile, FileSize(FInternalFile));
        BlockWrite(FInternalFile, ActiveBuffer^, FRecSize);
      end;
  end;
end;

procedure TMyDataSet.InternalRefresh;
begin
  { This is where we would refresh any buffers we are using
    between the data and TDataSet's internal record buffers. }
end;

procedure TMyDataSet.InternalSetToRecord(Buffer: PChar);
begin
  InternalGotoBookmark(Buffer + FBookmarkOffset);
end;

function TMyDataSet.IsCursorOpen: Boolean;
begin
  Result := FCursorOpen;
end;

procedure TMyDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer);
begin
  Move(Data^, Buffer[FBookmarkOffset], BookmarkSize);
end;

procedure TMyDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
begin
  PExtraRecInfo(Buffer + FExtraRecInfoOffset).BookmarkFlag := Value;
end;

procedure TMyDataSet.SetFieldData(Field: TField; Buffer: Pointer);
var
  Offset,
  DataSize: Integer;
  StrBuff: ShortString;
  NullFlags: ^LongInt;
  TimeStamp: TTimeStamp; { TTimeStamp is declared in SysUtils }
  DateTime: TDateTime;
begin
  if Field.FieldNo <> -1 then begin   { a physical field }
    { Cannot set fields while in OnCalcFields handler }
    if State = dsCalcFields then DatabaseError(SNotEditing);

    Offset := LongInt(FieldOffsets[Field.FieldNo - 1]);
    DataSize := Field.DataSize;  {?? need this? }
    { Current null flags }
    NullFlags := @ActiveBuffer[FNullFlagsOffset];

    if not Assigned(Buffer) then begin
      { If setting field to null, clear the field data
        and set the null flag }
      FillChar(ActiveBuffer[Offset], DataSize, #0);
      NullFlags^ := NullFlags^ or (1 shl (Field.FieldNo - 1));
    end
    else begin

      { Special handing for date/time fields }
      if Field.DataType in [ftDateTime, ftDate, ftTime] then begin
        case Field.DataType of
          ftDate:
            begin
              TimeStamp.Time := 0;
              TimeStamp.Date := TDateTimeRec(Buffer^).Date;
            end;
          ftTime:
            begin
              TimeStamp.Time := TDateTimeRec(Buffer^).Time;
              TimeStamp.Date := DateDelta;
            end;
          else
            try
              TimeStamp := MSecsToTimeStamp(TDateTimeRec(Buffer^).DateTime);
            except
              TimeStamp.Time := 0;
              TimeStamp.Date := 0;
            end;
        end;
        DateTime := TimeStampToDateTime(TimeStamp);
        Move(DateTime, ActiveBuffer[Offset], SizeOf(TDateTime));
      end
      else if Field.DataType = ftString then begin
        StrBuff := StrPas(Buffer);
        Move(StrBuff, ActiveBuffer[Offset], DataSize);
      end
      else
        Move(Buffer^, ActiveBuffer[Offset], DataSize);
      { Set flag to nonnull }
      NullFlags^ := NullFlags^ and not (1 shl (Field.FieldNo - 1));
    end;
  end
  else begin   { a calculated field }
    Offset := FCalcFieldsOffset + Field.Offset;
    Boolean(CalcBuffer[0]) := not Assigned(Buffer);
    if Assigned(Buffer) then begin
      Move(Buffer^, CalcBuffer[Offset + 1], Field.DataSize);
    end;
  end;

  if not (State in [dsCalcFields]) then
    DataEvent(deFieldChange, Longint(Field));
end;

end.